package PlPN;

#
# Pod::Html is kind of brain-dead:
#
# Place Z<> between function names and parentheses, otherwise Pod::Html
# assumes you meant to put C<...> around it
#
# Put explicit text in all links L<use my text, stupid|some::perl::module>,
# otherwise Pod::Html assumes you want "the X manpage". (Does not apply to
# relative links withing this file.)
#
# It also assumes you want a link if you have C<...> with text matching a
# potential link target. The only way I've found around that is to split it
# up into multiple pieces: C<wo>C<rd>. Looks correct in the resulting HTML,
# but it's ugly to have <code>wo</code><code>rd</code> in the source, and I
# shouldn't have to do it.
#

=head1 NAME

PlPN - Perl Plugin for Programmer's Notepad

=head1 SYNOPSIS

	use PlPN;
	
	PlPN->RegisterEvent($event_name, $subref);
	PlPN->RegisterScript($group, $name, $subref);
	
	# etc.

=head1 DESCRIPTION

Implements a Perl interface to Programmer's Notepad.

Basic objects:

=over

=item * L<PlPN::PN|PlPN::PN> - The Progammer's Notepad object

=item * L<PlPN::Document|PlPN::Document> - The document object

=item * L<PlPN::Options|PlPN::Options> - The options manager object

=item * L<PlPN::SearchOptions|PlPN::SearchOptions> - The search options object

=item * L<PlPN::TextOutput|PlPN::TextOutput> - The text output window object

=back

If the default implementation is not sufficient for you, the following
objects can give you finer-grained control over events and scripts:

=over

=item * L<PlPN::AppEventSink|PlPN::AppEventSink> - The application event
sink

=item * L<PlPN::DocumentEventSink|PlPN::DocumentEventSink> - The document
event sink

=item * L<PlPN::TextEditorEventSink|PlPN::TextEditorEventSink> - The text
editor event sink

=item * L<PlPN::ScriptRegistry|PlPN::ScriptRegistry> - The script registry
object

=item * L<PlPN::ScriptRunner|PlPN::ScriptRunner> - The script runner object

=item * L<PlPN::Recorder|PlPN::Recorder> - The macro recorder object

=back

It is also possible to add menu items in Programmer's Notepad, under the
C<Extensions> menu:

=over

=item * L<PlPN::Menu|PlPN::Menu> - The menu object

=back

=head2 Cycling the interpreter

The plugin gives Programmer's Notepad users the chance to cycle the Perl
interpreter. There are two reasons for this. First, if the Perl interpreter
has been running for a while, it may be using a lot of memory and slowing
down Programmer's Notepad. Cycling allows that memory to be released without
shutting down and restarting the entire program. Second, it allows for the
development of scripts without shutting down and restarting the entire
program, since every time the interpreter is cycled, the scripts are reread.

However, since cycling involves deleting and recreating the Perl
interpreter, all Perl variables are lost. Two options have been provided for
preserving your data. The simpler option is the L<RegisterData> method.
For more control, the L</OnBeforeCycle> and L</OnAfterCycle>
events and the L</CurrentDocuments> method are also provided.

=cut

use Symbol qw(delete_package);
use Exporter qw(import);
require DynaLoader;
use PlPN::Sinks;
use Storable;
use strict;

#
# since PN doesn't run on a console, redirect output
#
open STDOUT, ">PlPN.log" or die $!;
open STDERR, ">PlPN.err" or die $!;
select(STDERR);
$| = 1;
select(STDOUT);
$| = 1;

# $PluginVersion is defined in XS and not in Perl, so the perl compiler
# complains about it unless I predeclare it here. Similarly, PN is defined
# in XS and the compiler complains about using it without parentheses.
# Predeclaring these symbols overcomes the compiler's reticence.
our $PluginVersion;
sub PN;

bootstrap PlPN;

=head2 Customization

After loading F<PlPN.pm>, but before loading any script files, the file
F<plpn.init> in the scripts folder will be loaded. This is your chance to
customize the object, including replacing this default implementation with
your own object.

To do so, first create your object. For ease, you will probably want to
inherit from C<PlPN>, but this is not required. Then set the variable
C<$PlPN::PlPN> to an instance of your object, or if you have implemented
your implementation via class methods (like this default implementation
does), with your class name.

Note that if you do not inherit from C<PlPN>, you B<must> implement all the
methods listed below, since scripts may depend on them.

In addition, if F<plpn.init> returns a defined false value, no scripts will
be loaded. This allows you to replace the default script loading
implementation with your own. The scalar C<$PlPN::ScriptsFolder> will
contain the path to the default script folder.

Note that the function that loads scripts returns C<undef> on error, so you
must return a II<defined> false value to cancel script loading.

=cut

our $PlPN = __PACKAGE__;
our $ScriptsFolder;
our %ScriptFiles;

=head1 VERSIONS

This package has two version variables. C<$PlPN::PluginVersion> is the
version of the C++/XS plugin (F<PlPN.dll>). C<$PlPN::ModuleVersion> is the
version of the Perl module (F<PlPN.pm>).

=cut

our $ModuleVersion = 0.0.0.0;

our $TextOutput = PN->GetGlobalOutputWindow;
$SIG{__WARN__} = sub {
	print STDERR $_[0],"\n";
	$TextOutput->AddToolOutput("PlPN: $_[0]\n");
	$TextOutput->ShowOutput;
};

$SIG{__DIE__} = sub {
	print STDERR $_[0],"\n";
	$TextOutput->AddToolOutput("PlPN: $_[0]\n");
	$TextOutput->ShowOutput;
};

# copy our filehandle
our $CopyStdOut;
open($CopyStdOut, '>&', STDOUT);

our @ISA = qw(DynaLoader);

=head1 EXPORTS

Nothing is exported by default.

=over

=item PN

The L<PlPN::PN|PlPN::PN> object, which allows access to Programmer's
Notepad.

=item PN_EXT_IFACE_VERSION

The extension interface version. Probably not very useful for Perl programs,
but provided for the sake of completeness.

=item TRUE

=item FALSE

The special Perl values for true and false. Used with
L<PlPN::Options::Set|PlPN::Options/Set> and
L<PlPN::Options::Get|PlPN::Options/Get>.

=item :EExecFlags

Execution flags for L<PlPN::ScriptRunner::Exec|PlPN::ScriptRunner/Exec>.

=item :EFIFFileSet

File sets for L<PlPN::SearchOptions|PlPN::SearchOptions>.

=item :EFindWhere

Targets for L<PlPN::SearchOptions|PlPN::SearchOptions>.

=item :EMenuItemType

Menu item types for L<PlPN::Menu|PlPN::Menu>.

=item :FindNextResult

Result indicators for L<PlPN::PN::FindNext|PlPN::PN/FindNext> and
L<PlPN::Recorder::RecordSearchAction|PlPN::RecorderRecordSearchAction>.

=item :SearchType

Search type indicators for
L<PlPN::Recorder::RecordSearchAction|PlPN::Recorder/RecordSearchAction>.

=item :PNPath

Path indicator for L<PlPN::Options::GetPNPath|PlPN::Options/GetPNPath>.

=item :OptionsGroup

Group names for L<PlPN::Options::Set|PlPN::Options/Set>,
L<PlPN::Options::Get|PlPN::Options/Get>,
L<PlPN::Options::BeginGroupOperation|PlPN::Options/BeginGroupOperation>, and
L<PlPN::Options::EndGroupOperation|PlPN::Options/EndGroupOperation>.

=item :ECachedOption

Option indicators for L<PlPN::Options::GetCached|PlPN::Options/GetCached>
and L<PlPN::Options::SetCached|PlPN::Options/SetCached>.

=back

=cut

our %EXPORT_TAGS = (
	EExecFlags => [qw(efCaptureOutput efBuiltIn)],
	EFIFFileSet => [qw(fifPath fifSingleFile fifOpenFiles fifActiveProjectFiles)],
	EFindWhere => [qw(elwCurrentDoc elwAllDocs elwCurrentProj elwSelection)],
	EMenuItemType => [qw(miItem miSubmenu)],
	FindNextResult => [qw(fnNotFound fnFound fnReachedStart fnInvalidRegex fnInvalidSearch)],
	SearchType => [qw(stFindNext stReplace stReplaceAll)],
	PNPath => [qw(PNPATH_PN PNPATH_SCHEMES PNPATH_CLIPS PNPATH_TOOLS PNPATH_TAGGERS PNPATH_PROJECTTEMPLATES PNPATH_PRESETS PNPATH_USERMIN PNPATH_USERSETTINGS PNPATH_USERTOOLS PNPATH_COMPILEDSCHEMES PNPATH_USERCLIPS)],
	OptionsGroup => [qw(PNSK_MRU PNSK_MRUP PNSK_INTERFACE PNSK_EDITOR PNSK_PRINT PNSK_DEFGUI PNSK_FIND PNSK_SCHEMES PNSK_GENERAL)],
	ECachedOption => [qw(OUseTabs OTabWidth OShowIndentGuides OLineNumbers OMaximiseNew OShowFullPath OLineHighlight OWordWrap ORightGuide ORightColumn OLineHighlightColour ORightGuideColour OLineEndings OAlreadyOpenDropAction OAlreadyOpenAction ODefaultCodePage ODefaultScintillaCache OFindAlphaEnabled OFindAlphaPercent OVisibleLineEndings OVisibleWhiteSpace OManageTabOrder OConvertLinesOnPaste ODefaultCharSet OAutoComplete OAutoCompleteUseKeywords OAutoCompleteUseTags OAutoCompleteStartChars OAutoCompleteActivation OAutoCompleteTags OLineHighlightAlpha OFoldingEnabled OCaretXMove OCaretYMove OCaretXFlags OCaretYFlags OSmartHighlight OLinePaddingTop OLinePaddingBottom ODefaultEncoding OMultiByteCodePage OPTION_COUNT)],
);

our @EXPORT_OK = (
	qw(PN PN_EXT_IFACE_VERSION TRUE FALSE),
	@{ $EXPORT_TAGS{EExecFlags} },
	@{ $EXPORT_TAGS{EFIFFileSet} },
	@{ $EXPORT_TAGS{EFindWhere} },
	@{ $EXPORT_TAGS{EMenuItemType} },
	@{ $EXPORT_TAGS{FindNextResult} },
	@{ $EXPORT_TAGS{SearchType} },
	@{ $EXPORT_TAGS{PNPath} },
	@{ $EXPORT_TAGS{OptionsGroup} },
	@{ $EXPORT_TAGS{ECachedOption} },
);

# create sinks and script runner

our ($PlPNSink, $AppSink, $DocSink, $EditorSink);
$PlPNSink = new PlPN::Sink;
$AppSink = new PlPN::AppSink;
$DocSink = new PlPN::DocSink;
$EditorSink = new PlPN::EditorSink;
PN->AddEventSink($AppSink);

our $Runner = new PlPN::ScriptRunner;
PN->GetScriptRegistry->RegisterRunner('perl', $Runner);
PN->GetScriptRegistry->EnableSchemeScripts('perl', 'perl');

#
# object methods
#

# need to create sinks and allow users to register for events

=head1 METHODS

=over

=item RegisterEventZ<>($event, $subref)

=item UnregisterEventZ<>($event, $subref)

Registers an event with the system. Multiple subrefs can be registered to
the same event. The following events are available:

=over

=item OnBeforeCycleZ<>()

=item OnAfterCycleZ<>()

Called before and after the Perl interpreter is cycled.

=item OnNewDocumentZ<>($doc)

Called whenever a new document is opened.

=item AppCloseZ<>()

Called when Programmer's Notepad is about to close.

=item OnDocSelectedZ<>($doc)

Called whenever a document is made the active document.

=item OnFirstEditorCreatedZ<>($scintilla_window_handle)

Called when the first Scintilla window is created. The extensions
documentation indicates that this is useful for loading external lexers.
It's probably not very useful for Perl programs, but it is included for the
sake of completeness.

=item OnSchemeChangeZ<>($doc, $scheme)

Called whenever a document's scheme is changed.

=item OnDocClosingZ<>($doc)

Called whenever a document is closed.

=item OnAfterLoadZ<>($doc)

Called after a document has been loaded.

=item OnBeforeSaveZ<>($doc, $filename)

Called when a document is about to be saved.

=item OnAfterSaveZ<>($doc)

Called after a document has been saved.

=item OnModifiedChangedZ<>($doc, $modified)

Called when a document has changed its modified state.

=item OnWriteProtectChangedZ<>($doc, $protected)

Called when a document has changed its write-protect state.

=item OnCharAddedZ<>($doc, $char)

Called when a character is added to a document. The character passed in will
be a utf8 string. This is not called when text is pasted into a document, or
when control characters (such as backspace) are entered.

=back

=cut

my %event_map = (
	'OnBeforeCycle'         => 'PlPN',
	'OnAfterCycle'          => 'PlPN',
	'OnNewDocument'         => 'App',
	'OnAppClose'            => 'App',
	'OnDocSelected'         => 'App',
	'OnFirstEditorCreated'  => 'App',
	'OnSchemeChange'        => 'Doc',
	'OnDocClosing'          => 'Doc',
	'OnAfterLoad'           => 'Doc',
	'OnBeforeSave'          => 'Doc',
	'OnAfterSave'           => 'Doc',
	'OnModifiedChanged'     => 'Doc',
	'OnWriteProtectChanged' => 'Doc',
	'OnCharAdded'           => 'Editor',
);

sub RegisterEvent {
	my ($self, $event, $subref) = @_;
	my $type = $event_map{$event};
	$type or warn "Event '$event' is not mapped to a type";
	$type eq 'PlPN'   and $PlPNSink->register($event, $subref);
	$type eq 'App'    and $AppSink->register($event, $subref);
	$type eq 'Doc'    and $DocSink->register($event, $subref);
	$type eq 'Editor' and $EditorSink->register($event, $subref);
}

sub UnregisterEvent {
	my ($self, $event, $subref) = @_;
	my $type = $event_map{$event};
	$type eq 'PlPN'   and $PlPNSink->unregister($event, $subref);
	$type eq 'App'    and $AppSink->unregister($event, $subref);
	$type eq 'Doc'    and $DocSink->unregister($event, $subref);
	$type eq 'Editor' and $EditorSink->unregister($event, $subref);
}

=item RegisterScriptZ<>($group, $name, $subref)

Registers a script. C<$group> is optional and will default to C<perl>.

In the Programmer's Notepad Scripts window, C<$group> is the parent node and
C<$name> is the child node under it; double-clicking C<$name> will call
C<$subref>.

The extensions interface does not allow the unregistering of a script. Even
if the script is removed and the Perl interpreter is cycled, the entry in
the Scripts window will remain, and a message indicating the script has been
removed will appear if the user tries to run the script.

=cut

sub RegisterScript {
	my $self = shift;
	my $group = ($#_ > 1) ? shift : 'perl';
	my ($name, $subref) = @_;
	my $key = "$group\_$name";
	$key=~s/ //g;
	$Runner->{scripts}{$key} = $subref;
	my $scriptref = "perl:$key";
	$ScriptFiles{$group}{$name} = (caller)[1];
	PN->GetScriptRegistry->Add($group, $name, $scriptref);
}

our %DataFreezer;

=item RegisterDataZ<>($varname)

=item UnregisterDataZ<>($varname)

Registers a variable with the system so that it is preserved during cycling.
C<$varname> should be a fully-qualified variable name, with sigil.
Individual elements from arrays and hashes are allowed.

For example:

	package Test;

	our $Counter = 0;
	our $Scalar = 'Scalar';
	our @Array = qw(A r r a y);
	our %Hash = (H => 'a', s => 'h', e => 'd');
	our $SRef = \$Scalar;
	our $ARef = \@Array;
	our %HRef = \%Hash;

	PlPN->RegisterData('$Test::Counter');
	PlPN->RegisterData('$Test::Scalar');
	PlPN->RegisterData('@Test::Array');
	PlPN->RegisterData('%Test::Hash');
	PlPN->RegisterData('$Test::SRef');
	PlPN->RegisterData('$Test::ARef');
	PlPN->RegisterData('$Test::HRef');
	PlPN->RegisterData('$Test::Arrray[0]');
	PlPN->RegisterData('$Test::ARef->[0]');
	PlPN->RegisterData('$Test::Hash{H}');
	PlPN->RegisterData('$Test::HRef->{H}');

The data is transformed into a sequence of bytes via C<Storable::freeze> and
restored via C<Storable::thaw>.  It is restored after all scripts have been
read.

There is no guarantee it will handle objects correctly. If you wish to
preserve an object, you should supply the hooks desribed in L<Storable>.

Another option is to register events for L</OnBeforeCycle> and
L</OnAfterCycle> and do any special processing there.

=cut

sub RegisterData {
	my ($self, $varname) = @_;
	return if exists $DataFreezer{$varname};
	$DataFreezer{$varname} = eval "\\$varname";
}

sub UnregisterData {
	my ($self, $varname) = @_;
	delete $DataFreezer{$varname};
}

=item CurrentDocumentsZ<>()

This returns an arrayref of all the current documents. It should not be
necessary if you are using L</RegisterEvent>, but if you are creating your
own event sinks, then after the interpreter is cycled you may need to be
able to access the existing documents in order to hook your event sinks back
up.

=back

=head1 EVENTS

=over

=item OnBeforeCycleZ<>()

=item OnAfterCycleZ<>()

The default versions of these events. They save and restore registered data,
and call any registered subrefs for the events. You should never call them
yourself, except maybe from a child class version of the same event.

=back

=cut

# freezes the data and stores it in the options manager
sub OnBeforeCycle {
	my ($self) = @_;
	
	$PlPNSink->call('OnBeforeCycle');
	
	PN->GetOptionsManager->Set('PlPN', 'DataFreezer',
		unpack('H*', Storable::freeze(\%DataFreezer))
	);
	
	# unhook doc sinks
	for my $doc (@{ $PlPN->CurrentDocuments() }) {
		$doc->RemoveEventSink($DocSink);
		$doc->RemoveEventSink($EditorSink);
	}
}

# thaws the data and reassigns each member
sub OnAfterCycle {
	my ($self) = @_;
	
	my $freezer = Storable::thaw(pack('H*',
		PN->GetOptionsManager->Get('PlPN', 'DataFreezer', ''))
	);
	for my $key (keys %$freezer) {
		my $sigil = substr($key, 0, 1);
		my $ref = $freezer->{$key};
		eval qq($key = $sigil\$ref);
	}
	
	# rehook doc sinks
	for my $doc (@{ $PlPN->CurrentDocuments() }) {
		$doc->AddEventSink($DocSink);
		$doc->AddEventSink($EditorSink);
	}
	
	$PlPNSink->call('OnAfterCycle');
}

#
# functions for running scripts
# (adapted from perlembed.pod)
#

our %Cache;

=head1 UTILITY METHODS

=over

=item alertZ<>($message, $flags = 0, $title = 'PlPN')

Shows a windows MessageBox. Since this is mainly intended as a debugging
tool, no constants are provided for C<$flags>, but you can look them up
online if you really want them.

=item report_refcountZ<>($perlvar, $where)

Another debugging tool. This displays the reference count for a perl scalar
variable. Its purpose is to make sure the XS code that glues the Perl to the
C++ extension is properly handling reference counts. If you are getting
strange error message when passing variables to functions defined in XS, or
using variables created by XS, this might help track down the bug.

=item valid_package_nameZ<>($string)

Called when C<eval>ing a script file, this function generates a unique
package name; the script file is then wrapped into that package to protect
the C<main> namespace.

=cut

sub valid_package_name {
	my ($self, $string) = @_;
	$string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
	# second pass only for words starting with a digit
	$string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;

	# Dress it up as a real package name
	$string =~ s|/|::|g;
print "package name: $string\n";
	return "PlPN" . $string;
}

=item eval_fileZ<>($filename)

Called to C<eval> a script file, this function wraps the file into a unique
package name to protect the C<main> namespace.

=back

=cut

sub eval_file {
	my ($self, $filename) = @_;
#PlPN->alert("eval'ing $filename");
	my $package = $self->valid_package_name($filename);
	my $mtime = -M $filename;
	if(defined $Cache{$package}{mtime}
		&&
		$Cache{$package}{mtime} <= $mtime)
		{
		# we have compiled this subroutine already,
		# it has not been updated on disk, nothing left to do
#		print STDERR "already compiled $package->handler\n";
	}
	else {
		#wrap the code into a subroutine inside our unique package
		(my $dofile = $filename)=~s:\\:\\\\:g;
		my $eval = qq{
			package $package;
			sub handler {
				my \$ret = do "$dofile";
				warn \$! if \$!;
				warn \$\@ if \$\@;
				return \$ret;
			}
		};
		{
			# hide our variables within this block
			my($filename,$mtime,$package,$sub);
			eval $eval;
			warn $@ if $@;
		}
		warn $@ if $@;

		#cache it unless we're cleaning out each time
		$Cache{$package}{mtime} = $mtime;
	}

	my $ret = eval {$package->handler;};
	warn "Error from $filename: $!" if $!;
	warn "Error from $filename: $@" if $@;

	#take a look if you want
	#print Devel::Symdump->rnew($package)->as_string, $/;
	
	return $ret;
}

#
# class functions
#

=head1 UTILITY FUNCTIONS

Note that these are functions, not methods.

=over

=item initZ<>()

This is called by system immediately after loading C<PlPN.pm>. It checks for
the file C<plpn.init> in the scripts folder and loads it if it finds it. If 
C<plpn.init> returns a true value, or if it is not found, then all files
from the scripts folder with the extension C<.pl> will be loaded.

You can't redefine this function from your own code. Or rather, you can, but
it will do you no good. It is called only once, before any of your code has
been run.

=cut

sub init {
	$ScriptsFolder = PN->GetOptionsManager->GetPNPath;
	$ScriptsFolder=~s:\\:/:g;
	$ScriptsFolder=~s:/?$:/scripts:;
	
	if (-e "$ScriptsFolder/plpn.init") {
		my $success = PlPN->eval_file("$ScriptsFolder/plpn.init");
		# skip loading scripts on defined false return
		return if (defined $success and not $success)
	}
	
	opendir DIR, $ScriptsFolder or warn "Unable to read scripts folder '$ScriptsFolder': $!" and return;
	while (my $e = readdir DIR) {
		next unless $e=~/\.pl$/i;
		PlPN->eval_file("$ScriptsFolder/$e");
	}
	closedir DIR;
}

=item redirect_stdoutZ<>($sref)

=item restore_stdoutZ<>()

These are called by the system when the printed output of a script is
desired instead of the return value. C<$sref> is a scalar ref which will
hold the printed output.

You could redefine these from your own code, but you probably shouldn't.

=back

=cut

sub redirect_stdout {
	my ($sref) = @_;
	# close STDOUT and open it to the passed-in scalarref
	close STDOUT;
	open STDOUT, '>', $sref;
}

sub restore_stdout {
	close STDOUT;
	open(STDOUT, '>>&', $CopyStdOut);
}

=head1 COPYRIGHT and LICENCE

Copyright (c) 2012 Sean Healy. All rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;
